home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / util / interface-check.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  9.3 KB  |  238 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; This is called by the compiler after all compilation is complete
  3.  
  4. (define (check-interfaces mods)
  5.   (let ((mod-names (map (function module-name) mods)))
  6.     (dolist (imod (get-all-interfaces))
  7.       (when (memq (module-name imod) mod-names)
  8.     (let ((mod (locate-module (module-name imod))))
  9.       (check-export-table mod imod)))
  10.       (dolist (alist (module-interface-definitions imod))
  11.     (when (memq (car alist) mod-names)
  12.       (dolist (def (cdr alist))
  13.             (check-interface def (def-forward-to def)))))
  14.       (dolist (inst (module-instance-defs imod))
  15.         (let ((class (forward-def (instance-class inst)))
  16.           (type (forward-def (instance-algdata inst))))
  17.       (when (and (not (def-interface? class))
  18.              (not (def-interface? type)))
  19.         (let ((i1 (lookup-instance type class)))
  20.           (when (instance-in-interface? i1)
  21.                  (phase-error/objs 'missing-interface-instance (list inst)
  22.   "An instance for ~A was defined in an interface but is not present~%~
  23.    in the implementation."
  24.                    (get-object-name inst))))))))))
  25.       
  26. (define (check-export-table mod imod)
  27.   (let ((iet (module-export-table imod))
  28.     (met (module-export-table mod)))
  29.     (table-for-each (lambda (name group)
  30.               (declare (ignore group))
  31.               (let ((i-group (table-entry iet name)))
  32.             (check-export-group name i-group imod)))
  33.             met)
  34.     (table-for-each (lambda (name group)
  35.               (declare (ignore group))
  36.               (let ((m-group (table-entry met name)))
  37.             (check-export-group name m-group mod)))
  38.             iet)))
  39.  
  40. (define (check-export-group name g mod)
  41.   (when (not g)
  42.     (recoverable-error 'missing-entity
  43.      "~A ~A does not export ~A as indicated by the corresponding~%~
  44.       interface or implementation."
  45.       (get-object-kind mod) (get-object-name mod) (symbol->string name))))
  46.  
  47. ;;; This compares the definition found in an interface with the one
  48. ;;; in an implementation.
  49.  
  50. (define (check-interface idef def)
  51.  (unless (method-var? idef)  ; method vars are checked as a part of the class
  52.   (cond ((algdata? idef)
  53.      (if (not (algdata? def))
  54.          (interface-mismatch idef def
  55.             (format '#f
  56.   "The interface for data type ~A is not implemented as a data type." idef))
  57.          (compare-algdatas idef def)))
  58.     ((synonym? idef)
  59.      (if (not (synonym? def))
  60.          (interface-mismatch idef def
  61.             (format '#f
  62.   "The interface for synonym ~A is not implemented as a synonym." idef))
  63.          (compare-synonyms idef def)))
  64.         ((class? idef)
  65.      (if (not (class? def))
  66.          (interface-mismatch idef def
  67.             (format '#f
  68.   "The interface for class ~A is not implemented as a class." idef))
  69.          (compare-classes idef def)))
  70.         ((var? idef)
  71.      (if (method-var? def)
  72.          (interface-mismatch idef def
  73.              (format '#f
  74.   "The interface for variable ~A is implemented by a class method." idef))
  75.          (compare-vars idef def)))
  76.         ((instance? idef)
  77.      (compare-instances idef def))
  78.     (else 'con))))
  79.  
  80. ;;; This is used for dangling defs found in interface files.  As long as the
  81. ;;; types match and the tycon arity matches all is OK
  82.  
  83. (define (check-interface/dangling idef def)
  84.   (if (class? idef)
  85.       (unless (class? def)
  86.      (interface-mismatch idef def "Name used as both a class and type"))
  87.       (if (class? def)
  88.       (interface-mismatch idef def "Name used as both a class and type")
  89.       (when (not (eqv? (tycon-def-arity idef)
  90.                (tycon-def-arity def)))
  91.          (interface-arity-mismatch idef def)))))
  92.  
  93. (define (interface-mismatch def1 def2 msg)
  94.   (phase-error/objs 'interface-definition-mismatch (list def1 def2)
  95.     "The definition of ~A is not consistant.~%~A~%"
  96.     (get-object-name def1) msg))
  97.  
  98. (define (interface-arity-mismatch idef def)
  99.   (phase-error/objs 'interface-tycon-arity-mismatch def
  100.     "The arity of ~A is not the same as the arity used in an interface."
  101.     (get-object-name idef)))
  102.  
  103. ;;; The first algdata may be abstract.  In this case only the arity needs to
  104. ;;; be checked.
  105.  
  106. (define (compare-algdatas idef def)
  107.   (cond ((not (eqv? (tycon-def-arity idef) (tycon-def-arity def)))
  108.      (interface-arity-mismatch idef def))
  109.     ((null? (algdata-constrs idef))
  110.      'OK)
  111.     ((not (eqv? (algdata-n-constr idef) (algdata-n-constr def)))
  112.      (interface-mismatch idef def
  113.         "Data types have different number of constructors"))
  114.     ((not (eq? (algdata-implemented-by-lisp? idef)
  115.            (algdata-implemented-by-lisp? def)))
  116.      (interface-mismatch idef def
  117.           "Only one definition has an associated ImportLispType"))
  118.     (else
  119.      (compare-algdata-constrs? (algdata-constrs idef)
  120.                    (algdata-constrs def) idef def))))
  121.           
  122.          
  123. (define (compare-algdata-constrs? c1 c2 idef def)
  124.   (if (and (pair? c1)
  125.        (same-con? (car c1) (car c2) idef def))
  126.       (compare-algdata-constrs? (cdr c1) (cdr c2) idef def)
  127.       'OK))
  128.  
  129. (define (same-con? con1 con2 idef def)
  130.   (cond ((not (eq? (def-name con1) (def-name con2)))
  131.      (interface-mismatch idef def
  132.       (format '#f
  133.        "Data types have different constructors: ~A does not match ~A"
  134.        con1 con2))
  135.       '#f)
  136.     ((not (same-signature? (con-signature con1) (con-signature con2)))
  137.      (interface-mismatch idef def
  138.       (format '#f
  139.  "Constructors have different types:~% ~A :: ~A does not match~% ~A :: ~A"
  140.        con1 (con-signature con1) con2 (con-signature con2)))
  141.       '#f)
  142.     ((not (equal? (con-slot-strict? con1) (con-slot-strict? con2)))
  143.      (interface-mismatch idef def
  144.       (format '#f
  145.           "Constructor ~A have differing strictness properties" con1))
  146.       '#f)
  147.     ((not (same-fixity? (con-fixity con1) (con-fixity con2)))
  148.      (interface-mismatch idef def
  149.       (format '#f "Constructor ~A has differing fixities~%" con1))
  150.      '#f)
  151.     (else '#t)))
  152.  
  153. (define (same-fixity? f1 f2)
  154.   (or (and (not f1) (not f2))
  155.       (and (is-type? 'fixity f1) (is-type? 'fixity f2)
  156.        (eq? (fixity-associativity f1) (fixity-associativity f2))
  157.        (eqv? (fixity-precedence f1) (fixity-precedence f2)))))
  158.  
  159. (define (compare-synonyms idef def)
  160.   (when (or (not (equal? (synonym-args idef) (synonym-args def)))
  161.         (not (same-ast-type? (synonym-body idef) (synonym-body def))))
  162.    (interface-mismatch
  163.      idef def "Type synonym definitions are not identical")))
  164.  
  165. (define (same-ast-type? ty1 ty2)
  166.   (or (and (tyvar? ty1) (tyvar? ty2)
  167.        (eq? (tyvar-name ty1) (tyvar-name ty2)))
  168.       (and (tycon? ty1) (tycon? ty2)
  169.        (same-tycon? (tycon-def ty1) (tycon-def ty2))
  170.        (same-ast-type/l (tycon-args ty1) (tycon-args ty2)))))
  171.  
  172. (define (same-ast-type/l t1 t2)
  173.   (or (and (null? t1) (null? t2))
  174.       (and (pair? t1) (pair? t2) (same-ast-type? (car t1) (car t2))
  175.                              (same-ast-type/l (cdr t1) (cdr t2)))))
  176.  
  177. (define (compare-classes idef def) ;;
  178.  (cond ((not (every
  179.           (function same-class?) (class-super idef) (class-super def)))
  180.     (interface-mismatch idef def "Super classes do not match"))
  181.        ((not (eqv? (class-n-methods idef) (class-n-methods def)))
  182.     (interface-mismatch idef def
  183.           "Classes contain differing number of methods"))
  184.        ((not (every (function same-method?)
  185.              (class-method-vars idef) (class-method-vars def)))
  186.     'bad)
  187.        (else 'OK)))
  188.  
  189. (define (same-method? var1 var2)
  190.   (cond ((not (eq? (def-name var1) (def-name var2)))
  191.      (interface-mismatch (method-var-class var1) (method-var-class var2)
  192.         (format '#f "Class method ~A does not match ~A" var1 var2))
  193.      '#f)
  194.     (else
  195.      (compare-vars var1 var2)
  196.      '#t)))
  197.  
  198. (define (compare-vars idef def)
  199.    (cond ((not (same-signature? (var-type idef) (var-type def)))
  200.       (interface-mismatch idef def
  201.             (format '#f "Signature ~A does not match ~A"
  202.             (var-type idef) (var-type def))))
  203.      ((not (same-fixity? (var-fixity idef) (var-fixity def)))
  204.       (interface-mismatch idef def "Fixity mismatch"))
  205.      (else 'OK)))
  206.  
  207. (define (compare-instances idef def)
  208.   (unless (equal? (instance-gcontext idef) (instance-gcontext def))
  209.     (interface-mismatch idef def
  210.        "Instances have different contexts")))
  211.  
  212. ;;; This compares gtype signatures
  213. (define (same-signature? sig1 sig2)
  214.   (and (same-context? (gtype-context sig1) (gtype-context sig2))
  215.        (same-ntypes? (gtype-type sig1) (gtype-type sig2))))
  216.  
  217. (define (same-context? c1 c2)
  218.   (or (and (null? c1) (null? c2))
  219.       (and (pair? c1) (pair? c2)
  220.        (same-context-1 (car c1) (car c2))
  221.        (same-context? (cdr c1) (cdr c2)))))
  222.  
  223. (define (same-context-1 c1 c2)
  224.   (or (and (null? c1) (null? c2))
  225.       (and (pair? c1) (pair? c2)
  226.        (same-class? (car c1) (car c2))
  227.        (same-context-1 (cdr c1) (cdr c2)))))
  228.  
  229. (define (same-class? c1 c2)
  230.   (or (eq? c1 c2)
  231.       (and (eq? (def-name c1) (def-name c2))
  232.        (eq? (def-module c1) (def-module c2)))))
  233.  
  234. (define (same-ntypes? ty1 ty2)
  235.   (or (and (gtyvar? ty1) (gtyvar? ty2) (eqv? (gtyvar-varnum ty1)
  236.                          (gtyvar-varnum ty2)))
  237.       (and (ntycon? ty1) (ntycon? ty2)
  238.        (sa